
package Sgdb::DisplayRegisters ;
use Sgdb::Utils ;

use warnings ;
use strict ;
use integer ;
use bytes ;

my $show_floating ;
my $cmpct_display ;



init() ;

sub init { 1 }

sub new {

    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $text = ( pref ('registers-win-show-scrollbars') ?
                 $topf -> Scrolled ( 'Text', pref 'registers-win-text' ) :
                 $topf ->             Text ( pref 'registers-win-text' ) ) ;

    balloonset $text => <<DoC ;
Values colored red (if any) are those that have changed 
since the last pass. To refresh display, switch the pane.
DoC

    pref_tags $text, 'registers-win', qw/name changed same/;
    my %registers ;
    {# menu

      $show_floating = pref 'registers-show-floating' ;
      $cmpct_display = pref 'registers-compact-display' ;

      my $m = $text -> menu() ;
      $m -> delete( 0 => 'end' ) ;
      foreach my $menu (
                        ['checkbutton',
                         -label     => 'Show All Registers',
                         -variable  => \$show_floating ,
                         -command   => sub {
                             pref_set 'registers-show-floating', $show_floating ;
                             frame_update( $text, \%registers) ;
                         },
                        ],
                        ['checkbutton',
                         -label     => 'try Compact Display',
                         -variable  => \$cmpct_display,
                         -command   => sub {
                             pref_set 'registers-compact-display', $cmpct_display ;
                             frame_update( $text, \%registers) ;
                         } ,
                        ],
                        [ 'separator' ],
                        [ 'command',
                          -label   => 'Close',
                          -command => [\&hook_run, 'close-current-data-pane' ]
                        ],
                       ) { $m -> add ( @$menu ) }
    }

    pref_reconfigure 'registers-win-text' => $text  ;
    # returns:
    # 1. unpacked text object
    # 2. update command

    ( $text,
      sub { frame_update( $text, \%registers, @_ ) },
    ) ;
}

sub frame_update {

    my $t = shift ;
    my $regs = shift ;

    my $str = gdb_exec_quiet( $show_floating ?
                              "info all-registers" :
                              "info registers"
                            ) ;

    $t -> configure ( -state => 'normal' ) ;
    $t -> delete ( '1.0' => 'end') ;

    return $t -> insert ('end', 'Registers: unknown') unless $str ;
    # Algo: whats the heck! if registers are unknown,
    # let them have another scratch area!

    my $pre = '' ;
    my %newr ;
    my %newf ;
    my @regs ;
    my @raws ;
    my ($xmmn, $xmml) ;


#     my ( $sval, $sname, @sname ) = ( 0, 0 );

    foreach my $line ( split /^/, $str ) {

        if    ( $line =~ /^(\S+)\s+(0x[a-f\d]+)/ ) {
            my ($r, $v ) = ($1, $2) ;
            $newr{ $r } = $v ;
            push @regs, $r;
        }
        elsif ( $line =~ /^(\S+)\s+(.*raw.*)$/ ) {
            my ($r, $v ) = ($1, $2) ;
            $newf{ $r } = $v ;
            push @raws, $r ;
        }
        elsif ( $line =~ /^(\S+)\s+(\{.*)/s) {
            ($xmmn, $xmml) = ($1, $2) ;
        }
        elsif ( $line =~ /^\s*\}\s*\z/ and $xmmn ) {
            push @raws, $xmmn ;
            $newf{ $xmmn } = $xmml . $line ;
            undef  $xmmn ;
        }
        elsif ( $line =~ /\s/ and $xmmn) {
            $xmml .= $line ;
        }
        else {
            $pre .= $line ;
        }
    }

    $t -> insert( 'end', $pre ) if $pre ;

    if ( $cmpct_display ) {

        if ( exists $newr{ 'r31' } ) {

            my ($i, $j) ;
            for ( $i = 0 ; $i < 4 ; $i++ ) {

                $t -> insert ( 'end',
                               "\n" => 'name' ,
                               qw(R0-R7 R8-15 16-23 24-31)[$i] => 'name',
                               ' ' => 'name' ) ;

                for ( $j = $i*8 ; $j < $i*8+8 ; $j++ ) {

                    my $r = "r$j" ;
                    my $v = $newr{$r} ;
                    $v =~ s/^0x// ;
                    $t -> insert ( 'end',
                                   (' ' x (8 - length $v)) . $v =>
                                   (( !$$regs{ $r } or  $$regs{ $r } eq $v ) ?
                                    'same' :
                                    'changed' ) ,
                                   ' ' => 'name' ) ;
                    $$regs{ $r } = $v ;
                    delete $newr{$r} ;
                }
            }
            $t -> insert ( 'end', "\n" => 'name' ) ;
        }
        else {
            telthemloud "Can't compact registers display at this platform" ;
            $cmpct_display = 0 ;
        }
    }

    my $columns = pref ('registers-win-columns-num') || 4 ;
    my $lenv = 10 ; # (reverse sort map {length} values %newr)[0] ;
    my $lenr = 4  ; # (reverse sort map {length} keys   %newr)[2] ;
    my $i = 0 ;

    exists $newr{eflags} and $lenr = 6 ; # cisc i386

    foreach my $r ( @regs, @raws ) {
        if    ( exists $newr{ $r } ) {
            my $v = $newr{ $r } ;
            $i = 0 unless $i < $columns ;
            $t -> insert ( 'end', "\n" => 'name' ) unless $i++ ;
            $t -> insert ( 'end' ,
                           " $r"                       => 'name',
                           (' ' x ($lenr - length $r)) => 'name',
                          ':'                          => 'name',
                           $v  => (( !$$regs{ $r } or  $$regs{ $r } eq $v ) ?
                                                          'same' :
                                                          'changed' ),
                          (' ' x ($lenv - length $v )) => 'same',
                         ) ;
            $$regs{$r} = $v ;
        }
        elsif ( exists $newf{ $r } ) {
            my $v = $newf{ $r } ;
            $t -> insert ( 'end',
                           "\n $r"                     => 'name',
                           (' ' x ($lenr - length $r)) => 'name',
                          ':'                          => 'name',
                           $v  => (( !$$regs{ $r } or  $$regs{ $r } eq $v ) ?
                                                          'same' :
                                                          'changed' ),
                          (' ' x ($lenv - length $v )) => 'same',
                           ) ;
            $i = 0 ;
            $$regs{$r} = $v ;
        }
        else {
            telme "what is $r?" ;
        }
    }
    $t -> configure ( -state => 'disabled' ) ;
}
